home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / X11COLOR.C < prev    next >
C/C++ Source or Header  |  1991-07-23  |  19KB  |  547 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/microcode/RCS/x11color.c,v 1.3 1991/07/23 08:16:51 cph Exp $
  4.  
  5. Copyright (c) 1991 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Primitives for dealing with colors and color maps */
  36.  
  37. #include "scheme.h"
  38. #include "prims.h"
  39. #include "x11.h"
  40.  
  41. DEFINE_PRIMITIVE ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0)
  42. {
  43.   PRIMITIVE_HEADER(1);
  44.   {
  45.     struct xwindow * xw = (x_window_arg (1));
  46.     XWindowAttributes a;
  47.     if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
  48.       error_external_return ();
  49.     {
  50.       SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 23, true));
  51.       VECTOR_SET (result, 0, (long_to_integer (a . x)));
  52.       VECTOR_SET (result, 1, (long_to_integer (a . y)));
  53.       VECTOR_SET (result, 2, (long_to_integer (a . width)));
  54.       VECTOR_SET (result, 3, (long_to_integer (a . height)));
  55.       VECTOR_SET (result, 4, (long_to_integer (a . border_width)));
  56.       VECTOR_SET (result, 5, (long_to_integer (a . depth)));
  57.       VECTOR_SET (result, 6, (X_VISUAL_TO_OBJECT (a . visual)));
  58.       VECTOR_SET (result, 7, (long_to_integer (a . root)));
  59.       VECTOR_SET (result, 8, (long_to_integer (a . class)));
  60.       VECTOR_SET (result, 9, (long_to_integer (a . bit_gravity)));
  61.       VECTOR_SET (result, 10, (long_to_integer (a . win_gravity)));
  62.       VECTOR_SET (result, 11, (long_to_integer (a . backing_store)));
  63.       VECTOR_SET (result, 12, (long_to_integer (a . backing_planes)));
  64.       VECTOR_SET (result, 13, (long_to_integer (a . backing_pixel)));
  65.       VECTOR_SET (result, 14, (BOOLEAN_TO_OBJECT (a . save_under)));
  66.       VECTOR_SET (result, 15,
  67.           (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw)))));
  68.       VECTOR_SET (result, 16, (BOOLEAN_TO_OBJECT (a . map_installed)));
  69.       VECTOR_SET (result, 17, (long_to_integer (a . map_state)));
  70.       VECTOR_SET (result, 18, (long_to_integer (a . all_event_masks)));
  71.       VECTOR_SET (result, 19, (long_to_integer (a . your_event_mask)));
  72.       VECTOR_SET (result, 20, (long_to_integer (a . do_not_propagate_mask)));
  73.       VECTOR_SET (result, 21, (BOOLEAN_TO_OBJECT (a . override_redirect)));
  74.       VECTOR_SET (result, 22,
  75.           (long_to_integer (XScreenNumberOfScreen (a . screen))));
  76.       PRIMITIVE_RETURN (result);
  77.     }
  78.   }
  79. }
  80.  
  81. /* Visuals */
  82.  
  83. DEFINE_PRIMITIVE ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0)
  84. {
  85.   PRIMITIVE_HEADER (2);
  86.   PRIMITIVE_RETURN
  87.     (X_VISUAL_TO_OBJECT
  88.      (XDefaultVisual ((XD_DISPLAY (x_display_arg (1))), (arg_integer (2)))));
  89. }
  90.  
  91. DEFINE_PRIMITIVE ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0)
  92. {
  93.   PRIMITIVE_HEADER (1);
  94.   {
  95.     struct xwindow * xw = (x_window_arg (1));
  96.     XWindowAttributes a;
  97.     if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
  98.       error_external_return ();
  99.     PRIMITIVE_RETURN (X_VISUAL_TO_OBJECT (a . visual));
  100.   }
  101. }
  102.  
  103. DEFINE_PRIMITIVE ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0)
  104. {
  105.   PRIMITIVE_HEADER (1);
  106.   deallocate_x_visual (x_visual_arg (1));
  107.   PRIMITIVE_RETURN (UNSPECIFIC);
  108. }
  109.  
  110. DEFINE_PRIMITIVE("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0)
  111. /* Inputs: Scheme window or display
  112.            (the remaining are either #F or a valid value)
  113.            Visual-ID
  114.        Screen number (or #F is window supplied)
  115.        Depth
  116.        Class
  117.        Red-mask (integer)
  118.        Green-mask (integer)
  119.        Blue-mask (integer)
  120.        Colormap size
  121.        Bits per RGB
  122.  
  123.   Returns a vector of vectors, each of which has the following format:
  124.            Visual (Scheme format, for use in later calls)
  125.            Visual-ID
  126.        Screen number
  127.        Depth
  128.        Class
  129.        Red-mask (integer)
  130.        Green-mask (integer)
  131.        Blue-mask (integer)
  132.        Colormap size
  133.        Bits per RGB
  134. */
  135. #define LOAD_IF(argno, type, field, mask_bit)        \
  136.   if (ARG_REF(argno) != SHARP_F)            \
  137.   { VI.field = type arg_integer(argno);            \
  138.     VIMask |= mask_bit;                    \
  139.   }
  140. { PRIMITIVE_HEADER (10);
  141.   { Display *dpy;
  142.     long ScreenNumber;
  143.     XVisualInfo VI, *VIList, *ThisVI;
  144.     long VIMask = VisualNoMask;
  145.     long AnswerSize, i;
  146.     int AnswerCount;
  147.     SCHEME_OBJECT Result, This_Vector;
  148.  
  149.     if (ARG_REF(3) == SHARP_F)
  150.     { struct xwindow * xw = x_window_arg (1);
  151.       XWindowAttributes attrs;
  152.       
  153.       dpy = XW_DISPLAY(xw);
  154.       XGetWindowAttributes(dpy, XW_WINDOW(xw), &attrs);
  155.       ScreenNumber = XScreenNumberOfScreen(attrs.screen);
  156.     }
  157.     else
  158.     { struct xdisplay * xd = x_display_arg (1);
  159.       ScreenNumber = arg_integer(3);
  160.       dpy = XD_DISPLAY(xd);
  161.     }
  162.     VI.screen = ScreenNumber;
  163.     LOAD_IF(2, (VisualID), visualid, VisualIDMask);
  164.     LOAD_IF(4, (unsigned int), depth, VisualDepthMask);
  165.     LOAD_IF(5, (int), class, VisualClassMask);
  166.     LOAD_IF(6, (unsigned long), red_mask, VisualRedMaskMask);
  167.     LOAD_IF(7, (unsigned long), green_mask, VisualGreenMaskMask);
  168.     LOAD_IF(8, (unsigned long), blue_mask, VisualBlueMaskMask);
  169.     LOAD_IF(9, (int), colormap_size, VisualColormapSizeMask);
  170.     LOAD_IF(10, (int), bits_per_rgb, VisualBitsPerRGBMask);
  171.     VIList = XGetVisualInfo(dpy, VIMask, &VI, &AnswerCount);
  172.     AnswerSize = (AnswerCount + 1) + (11 * AnswerCount);
  173.     if (GC_Check (AnswerSize))
  174.     { XFree((PTR) VIList);
  175.       Primitive_GC (AnswerSize);
  176.     }
  177.     Result = allocate_marked_vector (TC_VECTOR, AnswerCount, false);
  178.     for (i=0, ThisVI=VIList; i < AnswerCount; i++, ThisVI++)
  179.     { This_Vector = allocate_marked_vector(TC_VECTOR, 10, false);
  180.       VECTOR_SET(This_Vector, 0, (X_VISUAL_TO_OBJECT (ThisVI->visual)));
  181.       VECTOR_SET(This_Vector, 1, long_to_integer((long) ThisVI->visualid));
  182.       VECTOR_SET(This_Vector, 2, long_to_integer(ThisVI->screen));
  183.       VECTOR_SET(This_Vector, 3, long_to_integer(ThisVI->depth));
  184.       VECTOR_SET(This_Vector, 4, long_to_integer(ThisVI->class));
  185.       VECTOR_SET(This_Vector, 5, long_to_integer(ThisVI->red_mask));
  186.       VECTOR_SET(This_Vector, 6, long_to_integer(ThisVI->green_mask));
  187.       VECTOR_SET(This_Vector, 7, long_to_integer(ThisVI->blue_mask));
  188.       VECTOR_SET(This_Vector, 8, long_to_integer(ThisVI->colormap_size));
  189.       VECTOR_SET(This_Vector, 9, long_to_integer(ThisVI->bits_per_rgb));
  190.       VECTOR_SET(Result, i, This_Vector);
  191.     }
  192.     XFree((PTR) VIList);
  193.     PRIMITIVE_RETURN(Result);
  194.   }
  195. }
  196.  
  197. /* Colormaps */
  198.  
  199. DEFINE_PRIMITIVE ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2,
  200.   "Given DISPLAY and SCREEN-NUMBER, return default colormap for screen.")
  201. {
  202.   PRIMITIVE_HEADER (2);
  203.   {
  204.     struct xdisplay * xd = (x_display_arg (1));
  205.     PRIMITIVE_RETURN
  206.       (X_COLORMAP_TO_OBJECT
  207.        ((XDefaultColormap ((XD_DISPLAY (xd)), (arg_integer (2)))), xd));
  208.   }
  209. }
  210.  
  211. DEFINE_PRIMITIVE ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1,
  212.   "Return WINDOW's colormap.")
  213. {
  214.   PRIMITIVE_HEADER (1);
  215.   {
  216.     struct xwindow * xw = (x_window_arg (1));
  217.     XWindowAttributes a;
  218.     if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
  219.       error_external_return ();
  220.     PRIMITIVE_RETURN (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw))));
  221.   }
  222. }
  223.  
  224. DEFINE_PRIMITIVE ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2,
  225.   "Set WINDOW's colormap to COLORMAP.")
  226. {
  227.   PRIMITIVE_HEADER (2);
  228.   {
  229.     struct xwindow * xw = (x_window_arg (1));
  230.     XSetWindowColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
  231.             (XCM_COLORMAP (x_colormap_arg (2))));
  232.   }
  233.   PRIMITIVE_RETURN (UNSPECIFIC);
  234. }
  235.  
  236. DEFINE_PRIMITIVE ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3,
  237.   "Given WINDOW, and VISUAL, create and return a colormap.\n\
  238. If third arg WRITEABLE is true, returned colormap may be modified.")
  239. {
  240.   PRIMITIVE_HEADER (3);
  241.   {
  242.     struct xwindow * xw = (x_window_arg (1));
  243.     PRIMITIVE_RETURN
  244.       (X_COLORMAP_TO_OBJECT
  245.        ((XCreateColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
  246.               (XV_VISUAL (x_visual_arg (2))), (BOOLEAN_ARG (3)))),
  247.     (XW_XD (xw))));
  248.   }
  249. }
  250.  
  251. DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1,
  252.   "Return a new copy of COLORMAP.")
  253. {
  254.   PRIMITIVE_HEADER (1);
  255.   {
  256.     struct xcolormap * xcm = (x_colormap_arg (1));
  257.     PRIMITIVE_RETURN
  258.       (X_COLORMAP_TO_OBJECT
  259.        ((XCopyColormapAndFree ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)))),
  260.     (XCM_XD (xcm))));
  261.   }
  262. }
  263.  
  264. DEFINE_PRIMITIVE ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1,
  265.   "Deallocate COLORMAP.")
  266. {
  267.   PRIMITIVE_HEADER (1);
  268.   {
  269.     struct xcolormap * xcm = (x_colormap_arg (1));
  270.     XFreeColormap ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)));
  271.     deallocate_x_colormap (xcm);
  272.   }
  273.   PRIMITIVE_RETURN (UNSPECIFIC);
  274. }
  275.  
  276. #define ARG_RGB_VALUE(argno) (arg_index_integer ((argno), 65536))
  277.  
  278. DEFINE_PRIMITIVE ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0)
  279. {
  280.   /* Input: colormap, red, green, blue
  281.      Returns: pixel, or #F if unable to allocate color cell.  */
  282.   PRIMITIVE_HEADER (4);
  283.   {
  284.     struct xcolormap * xcm = (x_colormap_arg (1));
  285.     XColor c;
  286.     (c . red) = (ARG_RGB_VALUE (2));
  287.     (c . green) = (ARG_RGB_VALUE (3));
  288.     (c . blue) = (ARG_RGB_VALUE (4));
  289.     PRIMITIVE_RETURN
  290.       ((XAllocColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)))
  291.        ? (long_to_integer (c . pixel))
  292.        : SHARP_F);
  293.   }
  294. }
  295.  
  296. DEFINE_PRIMITIVE ("X-STORE-COLOR", Prim_x_store_color, 5, 5,
  297.   "Input: colormap, pixel, r, g, b (r/g/b may be #f).")
  298. {
  299.   PRIMITIVE_HEADER (5);
  300.   {
  301.     struct xcolormap * xcm = (x_colormap_arg (1));
  302.     XColor c;
  303.     (c . pixel) = (arg_nonnegative_integer (2));
  304.     (c . flags) = 0;
  305.     if ((ARG_REF (3)) != SHARP_F)
  306.       {
  307.     (c . red) = (arg_index_integer (3, 65536));
  308.     (c . flags) |= DoRed;
  309.       }
  310.     if ((ARG_REF (4)) != SHARP_F)
  311.       {
  312.     (c . green) = (arg_index_integer (4, 65536));
  313.     (c . flags) |= DoGreen;
  314.       }
  315.     if ((ARG_REF (5)) != SHARP_F)
  316.       {
  317.     (c . blue) = (arg_index_integer (5, 65536));
  318.     (c . flags) |= DoBlue;
  319.       }
  320.     XStoreColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
  321.   }
  322.   PRIMITIVE_RETURN (UNSPECIFIC);
  323. }
  324.  
  325. #define CONVERT_COLOR_OBJECT(index, color, flag)            \
  326. {                                    \
  327.   SCHEME_OBJECT object = (VECTOR_REF (color_object, (index)));        \
  328.   if (object != SHARP_F)                        \
  329.     {                                    \
  330.       if (! ((INTEGER_P (object)) && (integer_to_long_p (object))))    \
  331.     goto losing_color_object;                    \
  332.       {                                    \
  333.     long value = (integer_to_long (object));            \
  334.     if ((value < 0) || (value > 65535))                \
  335.       goto losing_color_object;                    \
  336.     (colors_scan -> color) = value;                    \
  337.     (colors_scan -> flags) |= (flag);                \
  338.       }                                    \
  339.     }                                    \
  340. }
  341.  
  342. DEFINE_PRIMITIVE ("X-STORE-COLORS", Prim_x_store_colors, 2, 2,
  343.   "Input: colormap, vector of vectors, each of\n\
  344. which contains pixel, r, g, b (where r/g/b can be #f or integer).")
  345. {
  346.   PRIMITIVE_HEADER (2);
  347.   {
  348.     struct xcolormap * xcm = (x_colormap_arg (1));
  349.     SCHEME_OBJECT color_vector = (VECTOR_ARG (2));
  350.     unsigned long n_colors = (VECTOR_LENGTH (color_vector));
  351.     XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
  352.     {
  353.       SCHEME_OBJECT * vector_scan = (VECTOR_LOC (color_vector, 0));
  354.       SCHEME_OBJECT * vector_end = (vector_scan + n_colors);
  355.       XColor * colors_scan = colors;
  356.       while (vector_scan < vector_end)
  357.     {
  358.       SCHEME_OBJECT color_object = (*vector_scan++);
  359.       if (! ((VECTOR_P (color_object))
  360.          && ((VECTOR_LENGTH (color_object)) == 4)))
  361.         {
  362.         losing_color_object:
  363.           error_wrong_type_arg (3);
  364.         }
  365.       {
  366.         SCHEME_OBJECT pixel_object = (VECTOR_REF (color_object, 0));
  367.         if (! ((INTEGER_P (pixel_object))
  368.            && (integer_to_long_p (pixel_object))))
  369.           goto losing_color_object;
  370.         (colors_scan -> pixel) = (integer_to_long (pixel_object));
  371.       }
  372.       (colors_scan -> flags) = 0;
  373.       CONVERT_COLOR_OBJECT (1, red, DoRed);
  374.       CONVERT_COLOR_OBJECT (2, green, DoGreen);
  375.       CONVERT_COLOR_OBJECT (3, blue, DoBlue);
  376.       colors_scan += 1;
  377.     }
  378.     }
  379.     XStoreColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
  380.   }
  381.   PRIMITIVE_RETURN (UNSPECIFIC);
  382. }
  383.  
  384. DEFINE_PRIMITIVE ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0)
  385. {
  386.   /* Input: colormap, pixel ... */
  387.   PRIMITIVE_HEADER (LEXPR);
  388.   if ((LEXPR_N_ARGUMENTS ()) < 1)
  389.     signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  390.   {
  391.     struct xcolormap * xcm = (x_colormap_arg (1));
  392.     unsigned int n_pixels = ((LEXPR_N_ARGUMENTS ()) - 1);
  393.     unsigned long * pixels =
  394.       (dstack_alloc ((sizeof (unsigned long)) * n_pixels));
  395.     unsigned int i;
  396.     for (i = 0; (i < n_pixels); i += 1)
  397.       (pixels[i]) = (arg_integer (i + 2));
  398.     XFreeColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
  399.          pixels, n_pixels, 0);
  400.   }
  401.   PRIMITIVE_RETURN(UNSPECIFIC);
  402. }
  403.  
  404. DEFINE_PRIMITIVE ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0)
  405. {
  406.   /* Input: colormap, pixel
  407.      Output: vector of red, green, blue */
  408.   PRIMITIVE_HEADER (2);
  409.   {
  410.     struct xcolormap * xcm = (x_colormap_arg (1));
  411.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, true));
  412.     XColor c;
  413.     c . pixel = (arg_integer (2));
  414.     XQueryColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
  415.     VECTOR_SET (result, 0, (long_to_integer (c . red)));
  416.     VECTOR_SET (result, 1, (long_to_integer (c . green)));
  417.     VECTOR_SET (result, 2, (long_to_integer (c . blue)));
  418.     PRIMITIVE_RETURN (result);
  419.   }
  420. }
  421.  
  422. DEFINE_PRIMITIVE ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0)
  423. {
  424.   /* Input: colormap, pixel ...
  425.      Output: a vector of vectors, each with #(red, green, blue)  */
  426.   PRIMITIVE_HEADER (LEXPR);
  427.   if ((LEXPR_N_ARGUMENTS ()) < 1)
  428.     signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  429.   {
  430.     struct xcolormap * xcm = (x_colormap_arg (1));
  431.     unsigned int n_colors = ((LEXPR_N_ARGUMENTS ()) - 1);
  432.     XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
  433.     unsigned int i;
  434.     for (i = 0; (i < n_colors); i += 1)
  435.       ((colors[i]) . pixel) = (arg_integer (i + 2));
  436.     XQueryColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
  437.     {
  438.       SCHEME_OBJECT result =
  439.     (allocate_marked_vector (TC_VECTOR, n_colors, true));
  440.       for (i = 0; (i < n_colors); i += 1)
  441.     {
  442.       SCHEME_OBJECT cv = (allocate_marked_vector (TC_VECTOR, 3, true));
  443.       VECTOR_SET (cv, 0, (long_to_integer ((colors[i]) . red)));
  444.       VECTOR_SET (cv, 1, (long_to_integer ((colors[i]) . green)));
  445.       VECTOR_SET (cv, 2, (long_to_integer ((colors[i]) . blue)));
  446.       VECTOR_SET (result, i, cv);
  447.     }
  448.       PRIMITIVE_RETURN (result);
  449.     }
  450.   }
  451. }
  452.  
  453. /* Named colors */
  454.  
  455. DEFINE_PRIMITIVE ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0)
  456. { /* Input: colormap, string
  457.      Output: vector of pixel, red, green, blue
  458.   */
  459.   PRIMITIVE_HEADER (2);
  460.   {
  461.     struct xcolormap * xcm = (x_colormap_arg (1));
  462.     XColor TheColor;
  463.     if (! (XParseColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
  464.             (STRING_ARG (2)), (&TheColor))))
  465.       PRIMITIVE_RETURN (SHARP_F);
  466.     {
  467.       SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
  468.       VECTOR_SET(result, 0, long_to_integer(TheColor.pixel));
  469.       VECTOR_SET(result, 1, long_to_integer(TheColor.red));
  470.       VECTOR_SET(result, 2, long_to_integer(TheColor.green));
  471.       VECTOR_SET(result, 3, long_to_integer(TheColor.blue));
  472.       PRIMITIVE_RETURN (result);
  473.     }
  474.   }
  475. }
  476.  
  477. DEFINE_PRIMITIVE ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0)
  478. { /* Input: colormap, name
  479.      Returns: vector of closest pixel, red, green, blue
  480.                         exact   pixel, red, green, blue
  481.   */
  482.  
  483.   SCHEME_OBJECT Result;
  484.   XColor Exact, Closest;
  485.   struct xcolormap * xcm;
  486.   PRIMITIVE_HEADER (2);
  487.  
  488.   xcm = (x_colormap_arg (1));
  489.   XAllocNamedColor
  490.     ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
  491.      (STRING_ARG (2)), &Exact, &Closest);
  492.   Result = allocate_marked_vector(TC_VECTOR, 8, true);
  493.   VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
  494.   VECTOR_SET(Result, 1, long_to_integer(Closest.red));
  495.   VECTOR_SET(Result, 2, long_to_integer(Closest.green));
  496.   VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
  497.   VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
  498.   VECTOR_SET(Result, 5, long_to_integer(Exact.red));
  499.   VECTOR_SET(Result, 6, long_to_integer(Exact.green));
  500.   VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
  501.   PRIMITIVE_RETURN(Result);
  502. }
  503.  
  504. DEFINE_PRIMITIVE("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0)
  505. {
  506.   /* Input: colormap, color name, pixel, DoRed, DoGreen, DoBlue */
  507.   PRIMITIVE_HEADER(6);
  508.   {
  509.     struct xcolormap * xcm = (x_colormap_arg (1));
  510.     XStoreNamedColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
  511.               (STRING_ARG (2)), (arg_integer (4)),
  512.               (((BOOLEAN_ARG (4)) ? DoRed : 0)
  513.                | ((BOOLEAN_ARG (5)) ? DoGreen : 0)
  514.                | ((BOOLEAN_ARG (6)) ? DoBlue : 0)));
  515.   }
  516.   PRIMITIVE_RETURN(UNSPECIFIC);
  517. }
  518.  
  519. DEFINE_PRIMITIVE("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0)
  520. {
  521.   /* Input: colormap, name
  522.      Returns: vector of closest pixel, red, green, blue
  523.      exact   pixel, red, green, blue
  524.      */
  525.  
  526.   SCHEME_OBJECT Result;
  527.   XColor Exact, Closest;
  528.   struct xcolormap * xcm;
  529.   PRIMITIVE_HEADER (2);
  530.  
  531.   xcm = (x_colormap_arg (1));
  532.   if (! (XAllocNamedColor
  533.      ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
  534.       (STRING_ARG (2)), &Exact, &Closest)))
  535.     PRIMITIVE_RETURN (SHARP_F);
  536.   Result = allocate_marked_vector(TC_VECTOR, 8, true);
  537.   VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
  538.   VECTOR_SET(Result, 1, long_to_integer(Closest.red));
  539.   VECTOR_SET(Result, 2, long_to_integer(Closest.green));
  540.   VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
  541.   VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
  542.   VECTOR_SET(Result, 5, long_to_integer(Exact.red));
  543.   VECTOR_SET(Result, 6, long_to_integer(Exact.green));
  544.   VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
  545.   PRIMITIVE_RETURN(Result);
  546. }
  547.